module Print where

import Syntax
import Text.PrettyPrint

slash :: Doc
slash = text "/"

prettyExp :: HsExp -> String
prettyExp = render . pretty

sepMap :: Doc -> (a -> Doc) -> [a] -> Doc
sepMap s f = sep . punctuate s . map f

pretty :: HsExp -> Doc
pretty (HsVar name) = text name
pretty (HsInt n) = int n
pretty (HsString s) = doubleQuotes $ text s
pretty (HsPattern p) = slash <> text p <> slash
pretty (HsUnaryOp kind x) = text (prettyUnaryOp kind) <> pretty x

pretty (HsBinaryOp kind x y) = pretty x <> sop <> pretty y
  where
    op = text $ prettyBiOp kind
    sop = case kind of 
      HsOpMember  -> op
      HsOpRangeInclude -> op
      HsOpRangeExclude -> op
      otherwise -> space <> op <> space

pretty (HsBrace e) = parens $ pretty e

pretty (HsCall name es block) =
  case block of
    Nothing                  -> call
    Just (HsCallBlock args body) -> 
      let args' = sepMap comma text args
      in makeEndBlock (call <+> text "do |" <> args' <> text "|") (pretty body)
  where
    call = pretty name <> parens args
    args = sepMap comma pretty es

pretty (HsSequence k es) = 
  case k of 
    HsSeqSingleLine -> sep $ punctuate semi es'
    HsSeqMultiLine  -> vcat es'
  where
    es'  = map pretty es

pretty (HsBlock block body) = makeEndBlock (pretty' block) (pretty body)
  where
    pretty' (HsMethod opt def name args) = 
      sopt <+> text "def" <+> text name <> prettyArgs args
      where
        sopt = case opt of
          HsOptNone     -> empty
          HsOptStatic   -> text "static"
          HsOptOverride -> text "override"
          HsOptAbstract -> text "abstract"
    
    pretty' (HsClass name args super ints) = 
      text "class" <+> text name <> prettyArgs args <> extends <> implements
      where
        extends = case super of
          Nothing -> empty
          Just name -> space <> text "<" <+> text name
        implements = case ints of
          []        -> empty
          otherwise -> space <> text "implements" <+> sepMap comma text ints
    
    pretty' (HsModule name) = text "module" <+> text name
    pretty' (HsInterface name) = text "interface" <+> text name
    
    pretty' (HsStruct name args) = text "struct" <+> text name <> prettyArgs (Just args)

-- CASE
pretty (HsAlt (HsCase item) whens el) =
  makeEndBlock (text "case" <+> prettyMaybe item) body'
  where
    body' = (cat $ map (prettyAlt "when") whens) $$
            prettyElse el

-- IF/UNLESS
pretty (HsAlt kind (([cond],body):eis) el) =
  makeBlock (text kind' <+> pretty cond) (pretty body) $$
  (cat $ map (prettyAlt "elsif") eis) $$
  prettyElse el $$
  text "end"
  where
    kind' = case kind of
      HsIf     -> "if"
      HsUnless -> "unless"
  
pretty (HsLoop kind body) = makeEndBlock (prettyLoop kind) (pretty body)
  where
    prettyLoop (HsWhile cond) = text "while" <+> pretty cond
    prettyLoop (HsUntil cond) = text "until" <+> pretty cond
    prettyLoop (HsFor var range) = text "for" <+> pretty var <+> text "in" <+> pretty range

pretty (HsWith item body) = pretty body

pretty (HsReturn Nothing)  = text "return"
pretty (HsReturn (Just e)) = text "return" <+> pretty e

pretty (HsArray items) = brackets $ sepMap comma pretty items

pretty (HsHash keys) = braces $ sepMap comma prettyKey keys
  where
    prettyKey (HsHashKey key value) = pretty key <+> text "=>" <+> pretty value

pretty (HsArrayIndex array index) = pretty array <> (brackets $ pretty index)

pretty (HsListComprehension item fors cond) = brackets (pretty item <+> fors' <> cond')
  where
    cond' = case cond of Nothing -> empty
                         Just e  -> space <> text "if" <+> pretty e
    fors' = sep $ map aux fors
    aux (item, range) = text "for" <+> pretty item <+> text "in" <+> pretty range

pretty (HsRequire names) = text "require" <+> names'
  where
    names' = sepMap comma (quotes . text) names

pretty (HsTypedExp typename es) = text typename <+> sepMap comma pretty es

prettyMaybe Nothing  = empty
prettyMaybe (Just e) = pretty e

prettyAlt label (conds, body) = makeBlock (text label <+> conds') (pretty body)
  where
    conds' = sepMap comma pretty conds

prettyElse Nothing = empty
prettyElse (Just e) = makeBlock (text "else") (pretty e)

prettyArgs Nothing     = empty
prettyArgs (Just args) = parens $ sepMap comma prettyArg args
prettyArg (HsMethodArg name defval t) = t' <+> text name <> defval'
  where
    t' = case t of
      Nothing -> empty
      Just name -> text name
    defval' = case defval of 
      Nothing -> empty
      Just e  -> equals <> pretty e

makeEndBlock head body = makeBlock head body $$ text "end"
makeBlock    head body = head $$ 
                         if isEmpty body' then empty else body'
  where
    body' = nest 2 body

prettyUnaryOp :: HsUnaryOpKind -> String
prettyUnaryOp HsOpWordNot = "not"
prettyUnaryOp HsOpNot = "!"
prettyUnaryOp HsOpBitNot = "~"
prettyUnaryOp HsOpNegate = "-"
prettyUnaryOp HsOpRangeIncludeLeft = "..>"

prettyBiOp :: HsBinaryOpKind -> String
prettyBiOp HsOpWordIf = "if"
prettyBiOp HsOpWordUnless = "unless"
prettyBiOp HsOpWordWhile = "while"
prettyBiOp HsOpWordUntil = "until"
prettyBiOp HsOpWordOr = "or"
prettyBiOp HsOpWordAnd = "and"
prettyBiOp HsOpWordDefined = "defined?"
prettyBiOp HsOpSet = "="
prettyBiOp HsOpSetMod = "%="
prettyBiOp HsOpSetPat = "~="
prettyBiOp HsOpSetDiv = "/="
prettyBiOp HsOpSetSub = "-="
prettyBiOp HsOpSetAdd = "+="
prettyBiOp HsOpSetMul = "*="
prettyBiOp HsOpSetPow = "**="
prettyBiOp HsOpSetBitOr = "|="
prettyBiOp HsOpSetBitAnd = "&="
prettyBiOp HsOpSetOr = "||="
prettyBiOp HsOpSetAnd = "&&="
prettyBiOp HsOpSetShiftLeft = "<<="
prettyBiOp HsOpSetShiftRight = ">>="
prettyBiOp HsOpRangeInclude = ".."
prettyBiOp HsOpRangeExclude = "..."
prettyBiOp HsOpOr = "||"
prettyBiOp HsOpAnd = "&&"
prettyBiOp HsOpComp = "<=>"
prettyBiOp HsOpEq = "=="
prettyBiOp HsOpNotEq = "!="
prettyBiOp HsOpInRange = "==="
prettyBiOp HsOpEqPat = "=~"
prettyBiOp HsOpNotEqPat = "!~"
prettyBiOp HsOpLessEq = "<="
prettyBiOp HsOpLess = "<"
prettyBiOp HsOpGreat = ">"
prettyBiOp HsOpGreatEq = ">="
prettyBiOp HsOpBitOr = "|"
prettyBiOp HsOpBitXOr = "^"
prettyBiOp HsOpBitAnd = "&"
prettyBiOp HsOpShiftLeft = "<<"
prettyBiOp HsOpShiftRight = ">>"
prettyBiOp HsOpAdd = "+"
prettyBiOp HsOpSub = "-"
prettyBiOp HsOpMul = "*"
prettyBiOp HsOpDiv = "/"
prettyBiOp HsOpMod = "%"
prettyBiOp HsOpPow = "**"
prettyBiOp HsOpMember = "."
prettyBiOp HsOpHashMember = "->"